home *** CD-ROM | disk | FTP | other *** search
/ Amiga Tools 5 / Amiga Tools 5.iso / tools / developer-tools / andere sprachen / oberonv4 / oberon-src / system / opb.mod (.txt) < prev    next >
Encoding:
Oberon Text  |  1995-06-10  |  50.6 KB  |  1,449 lines
  1. Syntax24.Scn.Fnt
  2. Syntax10.Scn.Fnt
  3. (* Notify Ralf for maintenance of Non-FPU source *)
  4. MODULE OPB; (* RC 6.3.89 / 5.1.93 *)
  5. (* build parse tree *)
  6.  IMPORT OPT, OPS, OPM;
  7.  CONST
  8.   (* symbol values or ops *)
  9.   times = 1; slash = 2; div = 3; mod = 4;
  10.   and = 5; plus = 6; minus = 7; or = 8; eql = 9;
  11.   neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
  12.   in = 15; is = 16; ash = 17; msk = 18; len = 19;
  13.   conv = 20; abs = 21; cap = 22; odd = 23; not = 33;
  14.   (*SYSTEM*)
  15.   adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
  16.   (* object modes *)
  17.   Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
  18.   SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
  19.   (* Structure forms *)
  20.   Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
  21.   Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
  22.   Pointer = 13; ProcTyp = 14; Comp = 15;
  23.   intSet = {SInt..LInt}; realSet = {Real, LReal};
  24.   (* composite structure forms *)
  25.   Basic = 1; Array = 2; DynArr = 3; Record = 4;
  26.   (* nodes classes *)
  27.   Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6;
  28.   Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13;
  29.   Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19;
  30.   Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25;
  31.   Nreturn = 26; Nwith = 27; Ntrap = 28;
  32.   (*function number*)
  33.   assign = 0;
  34.   haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4;
  35.   entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9;
  36.   shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14;
  37.   inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32;
  38.   (*SYSTEM function number*)
  39.   adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23;
  40.   getfn = 24; putfn = 25; getrfn = 26; putrfn = 27;
  41.   bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31;
  42.   (* module visibility of objects *)
  43.   internal = 0; external = 1; externalR = 2;
  44.   (* procedure flags (conval^.setval) *)
  45.   hasBody = 1; isRedef = 2; slNeeded = 3;
  46.   AssertTrap = 0; (* default trap number *)
  47.   typSize*: PROCEDURE(typ: OPT.Struct; allocDesc: BOOLEAN);
  48.   exp: INTEGER; (*side effect of log*)
  49.   maxExp: LONGINT; (* max n in ASH(1, n) on this machine *)
  50.  PROCEDURE err(n: INTEGER);
  51.  BEGIN OPM.err(n)
  52.  END err;
  53.  PROCEDURE NewLeaf*(obj: OPT.Object): OPT.Node;
  54.   VAR node: OPT.Node;
  55.  BEGIN
  56.   CASE obj^.mode OF
  57.     Var:
  58.     node := OPT.NewNode(Nvar); node^.readonly := (obj^.vis = externalR) & (obj^.mnolev < 0)
  59.   | VarPar:
  60.     node := OPT.NewNode(Nvarpar)
  61.   | Con:
  62.     node := OPT.NewNode(Nconst); node^.conval := OPT.NewConst();
  63.     node^.conval^ := obj^.conval^ (* string is not copied, only its ref *)
  64.   | Typ:
  65.     node := OPT.NewNode(Ntype)
  66.   | LProc..IProc:
  67.     node := OPT.NewNode(Nproc)
  68.   ELSE err(127); node := OPT.NewNode(Nvar)
  69.   END ;
  70.   node^.obj := obj; node^.typ := obj^.typ;
  71.   RETURN node
  72.  END NewLeaf;
  73.  PROCEDURE Construct*(class: SHORTINT; VAR x: OPT.Node;  y: OPT.Node);
  74.   VAR node: OPT.Node;
  75.  BEGIN
  76.   node := OPT.NewNode(class); node^.typ := OPT.notyp;
  77.   node^.left := x; node^.right := y; x := node
  78.  END Construct;
  79.  PROCEDURE Link*(VAR x, last: OPT.Node; y: OPT.Node);
  80.  BEGIN
  81.   IF x = NIL THEN x := y ELSE last^.link := y END ;
  82.   WHILE y^.link # NIL DO y := y^.link END ;
  83.   last := y
  84.  END Link;
  85.  PROCEDURE BoolToInt(b: BOOLEAN): LONGINT;
  86.  BEGIN
  87.   IF b THEN RETURN 1 ELSE RETURN 0 END
  88.  END BoolToInt;
  89.  PROCEDURE IntToBool(i: LONGINT): BOOLEAN;
  90.  BEGIN
  91.   IF i = 0 THEN RETURN FALSE ELSE RETURN TRUE END
  92.  END IntToBool;
  93.  PROCEDURE NewBoolConst*(boolval: BOOLEAN): OPT.Node;
  94.   VAR x: OPT.Node;
  95.  BEGIN
  96.   x := OPT.NewNode(Nconst); x^.typ := OPT.booltyp;
  97.   x^.conval := OPT.NewConst(); x^.conval^.intval := BoolToInt(boolval); RETURN x
  98.  END NewBoolConst;
  99.  PROCEDURE OptIf*(VAR x: OPT.Node); (* x^.link = NIL *)
  100.   VAR if, pred: OPT.Node;
  101.  BEGIN
  102.   if := x^.left;
  103.   WHILE if^.left^.class = Nconst DO
  104.    IF IntToBool(if^.left^.conval^.intval) THEN x := if^.right; RETURN
  105.    ELSIF if^.link = NIL THEN x := x^.right; RETURN
  106.    ELSE if := if^.link; x^.left := if
  107.    END
  108.   END ;
  109.   pred := if; if := if^.link;
  110.   WHILE if # NIL DO
  111.    IF if^.left^.class = Nconst THEN
  112.     IF IntToBool(if^.left^.conval^.intval) THEN
  113.      pred^.link := NIL; x^.right := if^.right; RETURN
  114.     ELSE if := if^.link; pred^.link := if
  115.     END
  116.    ELSE pred := if; if := if^.link
  117.    END
  118.   END
  119.  END OptIf;
  120.  PROCEDURE Nil*(): OPT.Node;
  121.   VAR x: OPT.Node;
  122.  BEGIN
  123.   x := OPT.NewNode(Nconst); x^.typ := OPT.niltyp;
  124.   x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.nilval; RETURN x
  125.  END Nil;
  126.  PROCEDURE EmptySet*(): OPT.Node;
  127.   VAR x: OPT.Node;
  128.  BEGIN
  129.   x := OPT.NewNode(Nconst); x^.typ := OPT.settyp;
  130.   x^.conval := OPT.NewConst(); x^.conval^.setval := {}; RETURN x
  131.  END EmptySet;
  132.  PROCEDURE SetIntType(node: OPT.Node);
  133.   VAR v: LONGINT;
  134.  BEGIN v := node^.conval^.intval;
  135.   IF (OPM.MinSInt <= v) & (v <= OPM.MaxSInt) THEN node^.typ := OPT.sinttyp
  136.   ELSIF (OPM.MinInt <= v) & (v <= OPM.MaxInt) THEN node^.typ := OPT.inttyp
  137.   ELSIF (OPM.MinLInt <= v) & (v <= OPM.MaxLInt) (*bootstrap or cross*) THEN
  138.    node^.typ := OPT.linttyp
  139.   ELSE err(203); node^.typ := OPT.sinttyp; node^.conval^.intval := 1
  140.   END
  141.  END SetIntType;
  142.  PROCEDURE NewIntConst*(intval: LONGINT): OPT.Node;
  143.   VAR x: OPT.Node;
  144.  BEGIN
  145.   x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst();
  146.   x^.conval^.intval := intval; SetIntType(x); RETURN x
  147.  END NewIntConst;
  148.  PROCEDURE NewRealConst*(realval: LONGREAL; typ: OPT.Struct): OPT.Node;
  149.   VAR x: OPT.Node;
  150.  BEGIN
  151.   x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst();
  152.   x^.conval^.realval := realval; x^.typ := typ; x^.conval^.intval := OPM.ConstNotAlloc;
  153.   RETURN x
  154.  END NewRealConst;
  155.  PROCEDURE NewString*(VAR str: OPS.String; len: LONGINT): OPT.Node;
  156.   VAR x: OPT.Node;
  157.  BEGIN
  158.   x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst(); x^.typ := OPT.stringtyp;
  159.   x^.conval^.intval := OPM.ConstNotAlloc; x^.conval^.intval2 := len;
  160.   x^.conval^.ext := OPT.NewExt(); x^.conval^.ext^ := str;
  161.   RETURN x
  162.  END NewString;
  163.  PROCEDURE CharToString(n: OPT.Node);
  164.   VAR ch: CHAR;
  165.  BEGIN
  166.   n^.typ := OPT.stringtyp; ch := CHR(n^.conval^.intval); n^.conval^.ext := OPT.NewExt();
  167.   IF ch = 0X THEN n^.conval^.intval2 := 1 ELSE n^.conval^.intval2 := 2; n^.conval^.ext[1] := 0X END ;
  168.   n^.conval^.ext[0] := ch; n^.conval^.intval := OPM.ConstNotAlloc; n^.obj := NIL
  169.  END CharToString;
  170.  PROCEDURE BindNodes(class: SHORTINT; typ: OPT.Struct; VAR x: OPT.Node; y: OPT.Node);
  171.   VAR node: OPT.Node;
  172.  BEGIN
  173.   node := OPT.NewNode(class); node^.typ := typ;
  174.   node^.left := x; node^.right := y; x := node
  175.  END BindNodes;
  176.  PROCEDURE NotVar(x: OPT.Node): BOOLEAN;
  177.  BEGIN RETURN (x^.class >= Nconst) & ((x^.class # Nmop) OR (x^.subcl # val) OR (x^.left^.class >= Nconst))
  178.  END NotVar;
  179.  PROCEDURE DeRef*(VAR x: OPT.Node);
  180.  BEGIN
  181.   IF x^.class >= Nconst THEN err(78)
  182.   ELSIF x^.typ^.form = Pointer THEN BindNodes(Nderef, x^.typ^.BaseTyp, x, NIL)
  183.   ELSE err(84)
  184.   END
  185.  END DeRef;
  186.  PROCEDURE Index*(VAR x: OPT.Node; y: OPT.Node);
  187.   VAR f: INTEGER; typ: OPT.Struct;
  188.  BEGIN
  189.   f := y^.typ^.form;
  190.   IF x^.class >= Nconst THEN err(79)
  191.   ELSIF ~(f IN intSet) THEN err(80); y^.typ := OPT.inttyp END ;
  192.   IF x^.typ^.comp = Array THEN typ := x^.typ^.BaseTyp;
  193.    IF (y^.class = Nconst) & ((y^.conval^.intval < 0) OR (y^.conval^.intval >= x^.typ^.n)) THEN err(81) END
  194.   ELSIF x^.typ^.comp = DynArr THEN typ := x^.typ^.BaseTyp;
  195.    IF (y^.class = Nconst) & (y^.conval^.intval < 0) THEN err(81) END
  196.   ELSE err(82); typ := OPT.undftyp
  197.   END ;
  198.   BindNodes(Nindex, typ, x, y); x^.readonly := x^.left^.readonly
  199.  END Index;
  200.  PROCEDURE Field*(VAR x: OPT.Node; y: OPT.Object);
  201.  BEGIN (*x^.typ^.comp = Record*)
  202.   IF x^.class >= Nconst THEN err(77)
  203.   ELSIF (y # NIL) & (y^.mode IN {Fld, TProc}) THEN
  204.    BindNodes(Nfield, y^.typ, x, NIL); x^.obj := y;
  205.    x^.readonly := x^.left^.readonly OR ((y^.vis = externalR) & (y^.mnolev < 0))
  206.   ELSE err(83); x^.typ := OPT.undftyp
  207.   END
  208.  END Field;
  209.   PROCEDURE TypTest*(VAR x: OPT.Node; obj: OPT.Object; guard: BOOLEAN);
  210.     PROCEDURE GTT(t0, t1: OPT.Struct);
  211.       VAR node: OPT.Node; t: OPT.Struct;
  212.     BEGIN t := t0;
  213.       WHILE (t # NIL) & (t # t1) & (t # OPT.undftyp) DO t := t^.BaseTyp END ;
  214.       IF t # t1 THEN
  215.         WHILE (t1 # NIL) & (t1 # t0) & (t1 # OPT.undftyp) DO t1 :=
  216. t1^.BaseTyp END ;
  217.         IF t1 = t0 THEN
  218.           IF guard THEN BindNodes(Nguard, NIL, x, NIL); x^.readonly :=
  219. x^.left^.readonly
  220.           ELSE node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x;
  221.             node^.obj := obj; x := node
  222.           END
  223.         ELSE err(85)
  224.         END
  225.       ELSIF t0 # t1 THEN err(85)    (* prevent down guard *)
  226.       ELSIF ~guard THEN
  227.         IF x^.class = Nguard THEN  (* cannot skip guard *)
  228.           node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x;
  229.           node^.obj := obj; x := node
  230.         ELSE x := NewBoolConst(TRUE)
  231.         END
  232.       END
  233.     END GTT;
  234.   BEGIN
  235.     IF NotVar(x) THEN err(112)
  236.     ELSIF x^.typ^.form = Pointer THEN
  237.       IF x^.typ^.BaseTyp^.comp # Record THEN err(85)
  238.       ELSIF obj^.typ^.form = Pointer THEN GTT(x^.typ^.BaseTyp,
  239. obj^.typ^.BaseTyp)
  240.       ELSE err(86)
  241.       END
  242.     ELSIF (x^.typ^.comp = Record) & (x^.class = Nvarpar) & (obj^.typ^.comp =
  243. Record) THEN
  244.       GTT(x^.typ, obj^.typ)
  245.     ELSE err(87)
  246.     END ;
  247.     IF guard THEN x^.typ := obj^.typ ELSE x^.typ := OPT.booltyp END
  248.   END TypTest;
  249.  PROCEDURE In*(VAR x: OPT.Node; y: OPT.Node);
  250.   VAR f: INTEGER; k: LONGINT;
  251.  BEGIN f := x^.typ^.form;
  252.   IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126)
  253.   ELSIF (f IN intSet) & (y^.typ^.form = Set) THEN
  254.    IF x^.class = Nconst THEN
  255.     k := x^.conval^.intval;
  256.     IF (k < 0) OR (k > OPM.MaxSet) THEN err(202)
  257.     ELSIF y^.class = Nconst THEN x^.conval^.intval := BoolToInt(k IN y^.conval^.setval); x^.obj := NIL
  258.     ELSE BindNodes(Ndop, OPT.booltyp, x, y); x^.subcl := in
  259.     END
  260.    ELSE BindNodes(Ndop, OPT.booltyp, x, y); x^.subcl := in
  261.    END
  262.   ELSE err(92)
  263.   END ;
  264.   x^.typ := OPT.booltyp
  265.  END In;
  266.  PROCEDURE log(x: LONGINT): LONGINT;
  267.  BEGIN exp := 0;
  268.   IF x > 0 THEN
  269.    WHILE ~ODD(x) DO x := x DIV 2; INC(exp) END
  270.   END ;
  271.   RETURN x
  272.  END log;
  273.  PROCEDURE CheckRealType(f, nr: INTEGER; x: OPT.Const);
  274.   VAR min, max, r: LONGREAL;
  275.  BEGIN
  276.   IF f = Real THEN min := OPM.MinReal; max := OPM.MaxReal
  277.   ELSE min := OPM.MinLReal; max := OPM.MaxLReal
  278.   END ;
  279.   r := ABS(x^.realval);
  280.   IF (r > max) OR (r < min) THEN
  281.     err(nr); x^.realval := 1(*.0*)
  282.   ELSIF f = Real THEN x^.realval := SHORT(x^.realval) (* single precision only *)
  283.   END ;
  284.   x^.intval := OPM.ConstNotAlloc
  285.  END CheckRealType;
  286.  PROCEDURE MOp*(op: SHORTINT; VAR x: OPT.Node);
  287.   VAR f: INTEGER; typ: OPT.Struct;
  288.   PROCEDURE NewOp;
  289.    VAR node: OPT.Node;
  290.   BEGIN
  291.    node := OPT.NewNode(Nmop); node^.subcl := op; node^.typ := typ;
  292.    node^.left := x; x := node
  293.   END NewOp;
  294.  BEGIN
  295.   IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  296.   ELSE typ := x^.typ; f := typ^.form;
  297.    CASE op OF
  298.      not:
  299.      IF f = Bool THEN
  300.       IF x^.class = Nconst THEN
  301.        x^.conval^.intval := BoolToInt(~IntToBool(x^.conval^.intval)); x^.obj := NIL
  302.       ELSE NewOp
  303.       END
  304.      ELSE err(98)
  305.      END
  306.    | plus:
  307.      IF ~(f IN intSet + realSet) THEN err(96) END
  308.    | minus:
  309.      IF f IN intSet + realSet +{Set}THEN
  310.       IF x^.class = Nconst THEN
  311.        IF f IN intSet THEN
  312.         IF x^.conval^.intval = MIN(LONGINT) THEN err(203)
  313.         ELSE x^.conval^.intval := -x^.conval^.intval; SetIntType(x)
  314.         END
  315.        ELSIF f IN realSet THEN x^.conval^.realval := -x^.conval^.realval
  316.        ELSE x^.conval^.setval := -x^.conval^.setval
  317.        END ;
  318.        x^.obj := NIL
  319.       ELSE NewOp
  320.       END
  321.      ELSE err(97)
  322.      END
  323.    | abs:
  324.      IF f IN intSet + realSet THEN
  325.       IF x^.class = Nconst THEN
  326.        IF f IN intSet THEN
  327.         IF x^.conval^.intval = MIN(LONGINT) THEN err(203)
  328.         ELSE x^.conval^.intval := ABS(x^.conval^.intval); SetIntType(x)
  329.         END
  330.        ELSE x^.conval^.realval := ABS(x^.conval^.realval)
  331.        END ;
  332.        x^.obj := NIL
  333.       ELSE NewOp
  334.       END
  335.      ELSE err(111)
  336.      END
  337.    | cap:
  338.      IF f = Char THEN
  339.       IF x^.class = Nconst THEN
  340.        x^.conval^.intval := ORD(CAP(CHR(x^.conval^.intval))); x^.obj := NIL
  341.       ELSE NewOp
  342.       END
  343.      ELSE err(111); x^.typ := OPT.chartyp
  344.      END
  345.    | odd:
  346.      IF f IN intSet THEN
  347.       IF x^.class = Nconst THEN
  348.        x^.conval^.intval := BoolToInt(ODD(x^.conval^.intval)); x^.obj := NIL
  349.       ELSE NewOp
  350.       END
  351.      ELSE err(111)
  352.      END ;
  353.      x^.typ := OPT.booltyp
  354.    | adr: (*SYSTEM.ADR*)
  355.      IF (x^.class < Nconst) OR (f = String) THEN NewOp
  356.      ELSE err(127)
  357.      END ;
  358.      x^.typ := OPT.linttyp
  359.    | cc: (*SYSTEM.CC*)
  360.      IF (f IN intSet) & (x^.class = Nconst) THEN
  361.       IF (0 <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxCC) THEN NewOp ELSE err(219) END
  362.      ELSE err(69)
  363.      END ;
  364.      x^.typ := OPT.booltyp
  365.    END
  366.   END
  367.  END MOp;
  368.  PROCEDURE CheckPtr(x, y: OPT.Node);
  369.   VAR g: INTEGER; p, q, t: OPT.Struct;
  370.  BEGIN g := y^.typ^.form;
  371.   IF g = Pointer THEN
  372.    p := x^.typ^.BaseTyp; q := y^.typ^.BaseTyp;
  373.    IF (p^.comp = Record) & (q^.comp = Record) THEN
  374.     IF p^.extlev < q^.extlev THEN t := p; p := q; q := t END ;
  375.     WHILE (p # q) & (p # NIL) & (p # OPT.undftyp) DO p := p^.BaseTyp END ;
  376.     IF p = NIL THEN err(100) END
  377.    ELSE err(100)
  378.    END
  379.   ELSIF g # NilTyp THEN err(100)
  380.   END
  381.  END CheckPtr;
  382.  PROCEDURE CheckParameters*(fp, ap: OPT.Object; checkNames: BOOLEAN);
  383.   VAR ft, at: OPT.Struct;
  384.  BEGIN
  385.   WHILE fp # NIL DO
  386.    IF ap # NIL THEN
  387.     ft := fp^.typ; at := ap^.typ;
  388.     WHILE (ft^.comp = DynArr) & (at^.comp = DynArr) DO
  389.      ft := ft^.BaseTyp; at := at^.BaseTyp
  390.     END ;
  391.     IF ft # at THEN
  392.      IF (ft^.form = ProcTyp) & (at^.form = ProcTyp) THEN
  393.       IF ft^.BaseTyp = at^.BaseTyp THEN CheckParameters(ft^.BaseTyp^.link, at^.BaseTyp^.link, FALSE)
  394.       ELSE err(117)
  395.       END
  396.      ELSE err(115)
  397.      END
  398.     END ;
  399.     IF (fp^.mode # ap^.mode) OR checkNames & (fp^.name # ap^.name) THEN err(115) END ;
  400.     ap := ap^.link
  401.    ELSE err(116)
  402.    END ;
  403.    fp := fp^.link
  404.   END ;
  405.   IF ap # NIL THEN err(116) END
  406.  END CheckParameters;
  407.  PROCEDURE CheckProc(x: OPT.Struct; y: OPT.Object); (* proc var x := proc y, check compatibility *)
  408.  BEGIN
  409.   IF y^.mode IN {XProc, IProc, LProc} THEN
  410.    IF y^.mode = LProc THEN
  411.     IF y^.mnolev = 0 THEN y^.mode := XProc
  412.     ELSE err(73)
  413.     END
  414.    END ;
  415.    IF x^.BaseTyp = y^.typ THEN CheckParameters(x^.link, y^.link, FALSE)
  416.    ELSE err(117)
  417.    END
  418.   ELSE err(113)
  419.   END
  420.  END CheckProc;
  421.  PROCEDURE ConstOp(op: INTEGER; x, y: OPT.Node);
  422.   VAR f, g: INTEGER; xval, yval: OPT.Const; xv, yv: LONGINT;
  423.     temp: BOOLEAN; (* temp avoids err 215 *)
  424.   PROCEDURE ConstCmp(): INTEGER;
  425.    VAR res: INTEGER;
  426.   BEGIN
  427.    CASE f OF
  428.      Undef:
  429.      res := eql
  430.    | Byte, Char..LInt:
  431.      IF xval^.intval < yval^.intval THEN res := lss
  432.      ELSIF xval^.intval > yval^.intval THEN res := gtr
  433.      ELSE res := eql
  434.      END
  435.    | Real, LReal:
  436.      IF xval^.realval < yval^.realval THEN res := lss
  437.      ELSIF xval^.realval > yval^.realval THEN res := gtr
  438.      ELSE res := eql
  439.      END
  440.    | Bool:
  441.      IF xval^.intval # yval^.intval THEN res := neq
  442.      ELSE res := eql
  443.      END
  444.    | Set:
  445.      IF xval^.setval # yval^.setval THEN res := neq
  446.      ELSE res := eql
  447.      END
  448.    | String:
  449.      IF xval^.ext^ < yval^.ext^ THEN res := lss
  450.      ELSIF xval^.ext^ > yval^.ext^ THEN res := gtr
  451.      ELSE res := eql
  452.      END
  453.    | NilTyp, Pointer, ProcTyp:
  454.      IF xval^.intval # yval^.intval THEN res := neq
  455.      ELSE res := eql
  456.      END
  457.    END ;
  458.    x^.typ := OPT.booltyp; RETURN res
  459.   END ConstCmp;
  460.  BEGIN
  461.   f := x^.typ^.form; g := y^.typ^.form; xval := x^.conval; yval := y^.conval;
  462.   IF f # g THEN
  463.    CASE f OF
  464.      Char:
  465.      IF g = String THEN CharToString(x)
  466.      ELSE err(100); y^.typ := x^.typ; yval^ := xval^
  467.      END ;
  468.    | SInt:
  469.      IF g IN intSet THEN x^.typ := y^.typ
  470.      ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval
  471.      ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval
  472.      ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  473.      END
  474.    | Int:
  475.      IF g = SInt THEN y^.typ := OPT.inttyp
  476.      ELSIF g IN intSet THEN x^.typ := y^.typ
  477.      ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval
  478.      ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval
  479.      ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  480.      END
  481.    | LInt:
  482.      IF g IN intSet THEN y^.typ := OPT.linttyp
  483.      ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval
  484.      ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval
  485.      ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  486.      END
  487.    | Real:
  488.      IF g IN intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval
  489.      ELSIF g = LReal THEN x^.typ := OPT.lrltyp
  490.      ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  491.      END
  492.    | LReal:
  493.      IF g IN intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval
  494.      ELSIF g = Real THEN y^.typ := OPT.lrltyp
  495.      ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  496.      END
  497.    | String:
  498.      IF g = Char THEN CharToString(y); g := String
  499.      ELSE err(100); y^.typ := x^.typ; yval^ := xval^
  500.      END ;
  501.    | NilTyp:
  502.      IF ~(g IN {Pointer, ProcTyp}) THEN err(100) END
  503.    | Pointer:
  504.      CheckPtr(x, y)
  505.    | ProcTyp:
  506.      IF g # NilTyp THEN err(100) END
  507.    ELSE err(100); y^.typ := x^.typ; yval^ := xval^
  508.    END ;
  509.    f := x^.typ^.form
  510.   END ; (* {x^.typ = y^.typ} *)
  511.   CASE op OF
  512.     times:
  513.     IF f IN intSet THEN xv := xval^.intval; yv := yval^.intval;
  514.      IF (xv = 0) OR (yv = 0) OR (* division with negative numbers is not defined *)
  515.       (xv > 0) & (yv > 0) & (yv <= MAX(LONGINT) DIV xv) OR
  516.       (xv > 0) & (yv < 0) & (yv >= MIN(LONGINT) DIV xv) OR
  517.       (xv < 0) & (yv > 0) & (xv >= MIN(LONGINT) DIV yv) OR
  518.       (xv < 0) & (yv < 0) & (xv # MIN(LONGINT)) & (yv # MIN(LONGINT)) & (-xv <= MAX(LONGINT) DIV (-yv)) THEN
  519.       xval^.intval := xv * yv; SetIntType(x)
  520.      ELSE err(204)
  521.      END
  522.     ELSIF f IN realSet THEN
  523.      temp := ABS(yval^.realval) <= 1(*.0*);
  524.      IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) / ABS(yval^.realval)) THEN
  525.       xval^.realval := xval^.realval * yval^.realval; CheckRealType(f, 204, xval)
  526.      ELSE err(204)
  527.      END
  528.     ELSIF f = Set THEN
  529.      xval^.setval := xval^.setval * yval^.setval
  530.     ELSIF f # Undef THEN err(101)
  531.     END
  532.   | slash:
  533.     IF f IN intSet THEN
  534.      IF yval^.intval # 0 THEN
  535.       xval^.realval := xval^.intval / yval^.intval; CheckRealType(Real, 205, xval)
  536.      ELSE err(205); xval^.realval := 1(*.0*)
  537.      END ;
  538.      x^.typ := OPT.realtyp
  539.     ELSIF f IN realSet THEN
  540.      temp := ABS(yval^.realval) >= 1(*.0*);
  541.      IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) * ABS(yval^.realval)) THEN
  542.       xval^.realval := xval^.realval / yval^.realval; CheckRealType(f, 205, xval)
  543.      ELSE err(205)
  544.      END
  545.     ELSIF f = Set THEN
  546.      xval^.setval := xval^.setval / yval^.setval
  547.     ELSIF f # Undef THEN err(102)
  548.     END
  549.   | div:
  550.     IF f IN intSet THEN
  551.      IF yval^.intval # 0 THEN
  552.       xval^.intval := xval^.intval DIV yval^.intval; SetIntType(x)
  553.      ELSE err(205)
  554.      END
  555.     ELSIF f # Undef THEN err(103)
  556.     END
  557.   | mod:
  558.     IF f IN intSet THEN
  559.      IF yval^.intval # 0 THEN
  560.       xval^.intval := xval^.intval MOD yval^.intval; SetIntType(x)
  561.      ELSE err(205)
  562.      END
  563.     ELSIF f # Undef THEN err(104)
  564.     END
  565.   | and:
  566.     IF f = Bool THEN
  567.      xval^.intval := BoolToInt(IntToBool(xval^.intval) & IntToBool(yval^.intval))
  568.     ELSE err(94)
  569.     END
  570.   | plus:
  571.     IF f IN intSet THEN
  572.      temp := (yval^.intval >= 0) & (xval^.intval <= MAX(LONGINT) - yval^.intval);
  573.      IF temp OR (yval^.intval < 0) & (xval^.intval >= MIN(LONGINT) - yval^.intval) THEN
  574.        INC(xval^.intval, yval^.intval); SetIntType(x)
  575.      ELSE err(206)
  576.      END
  577.     ELSIF f IN realSet THEN
  578.      temp := (yval^.realval >= 0(*.0*)) & (xval^.realval <= MAX(LONGREAL) - yval^.realval);
  579.      IF temp OR (yval^.realval < 0(*.0*)) & (xval^.realval >= -MAX(LONGREAL) - yval^.realval) THEN
  580.        xval^.realval := xval^.realval + yval^.realval; CheckRealType(f, 206, xval)
  581.      ELSE err(206)
  582.      END
  583.     ELSIF f = Set THEN
  584.      xval^.setval := xval^.setval + yval^.setval
  585.     ELSIF f # Undef THEN err(105)
  586.     END
  587.   | minus:
  588.     IF f IN intSet THEN
  589.      IF (yval^.intval >= 0) & (xval^.intval >= MIN(LONGINT) + yval^.intval) OR
  590.       (yval^.intval < 0) & (xval^.intval <= MAX(LONGINT) + yval^.intval) THEN
  591.        DEC(xval^.intval, yval^.intval); SetIntType(x)
  592.      ELSE err(207)
  593.      END
  594.     ELSIF f IN realSet THEN
  595.      temp := (yval^.realval >= 0(*.0*)) & (xval^.realval >= -MAX(LONGREAL) + yval^.realval);
  596.      IF temp OR (yval^.realval < 0(*.0*)) & (xval^.realval <= MAX(LONGREAL) + yval^.realval) THEN
  597.        xval^.realval := xval^.realval - yval^.realval; CheckRealType(f, 207, xval)
  598.      ELSE err(207)
  599.      END
  600.     ELSIF f = Set THEN
  601.      xval^.setval := xval^.setval - yval^.setval
  602.     ELSIF f # Undef THEN err(106)
  603.     END
  604.   | or:
  605.     IF f = Bool THEN
  606.      xval^.intval := BoolToInt(IntToBool(xval^.intval) OR IntToBool(yval^.intval))
  607.     ELSE err(95)
  608.     END
  609.   | eql:
  610.     xval^.intval := BoolToInt(ConstCmp() = eql)
  611.   | neq:
  612.     xval^.intval := BoolToInt(ConstCmp() # eql)
  613.   | lss:
  614.     IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  615.     ELSE xval^.intval := BoolToInt(ConstCmp() = lss)
  616.     END
  617.   | leq:
  618.     IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  619.     ELSE xval^.intval := BoolToInt(ConstCmp() # gtr)
  620.     END
  621.   | gtr:
  622.     IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  623.     ELSE xval^.intval := BoolToInt(ConstCmp() = gtr)
  624.     END
  625.   | geq:
  626.     IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  627.     ELSE xval^.intval := BoolToInt(ConstCmp() # lss)
  628.     END
  629.   END
  630.  END ConstOp;
  631.  PROCEDURE Convert(VAR x: OPT.Node; typ: OPT.Struct);
  632.   VAR node: OPT.Node; f, g: INTEGER; k: LONGINT; r: LONGREAL;
  633.  BEGIN f := x^.typ^.form; g := typ^.form;
  634.   IF x^.class = Nconst THEN
  635.    IF f IN intSet THEN
  636.     IF g IN intSet THEN
  637.      IF f > g THEN SetIntType(x);
  638.       IF x^.typ^.form > g THEN err(203); x^.conval^.intval := 1 END
  639.      END
  640.     ELSIF g IN realSet THEN x^.conval^.realval := x^.conval^.intval; x^.conval^.intval := OPM.ConstNotAlloc
  641.     ELSE (*g = Char*) k := x^.conval^.intval;
  642.      IF (0 > k) OR (k > 0FFH) THEN err(220) END
  643.     END
  644.    ELSIF f IN realSet THEN
  645.     IF g IN realSet THEN CheckRealType(g, 203, x^.conval)
  646.     ELSE (*g = LInt*)
  647.      r := x^.conval^.realval;
  648.      IF (r < MIN(LONGINT)) OR (r > MAX(LONGINT)) THEN err(203); r := 1 END ;
  649.      x^.conval^.intval := ENTIER(r); SetIntType(x)
  650.     END
  651.    ELSE (* (f IN {Char, Byte}) & (g IN {Byte} + intSet) OR (f = Undef) *)
  652.    END ;
  653.    x^.obj := NIL
  654.   ELSIF (x^.class = Nmop) & (x^.subcl = conv) & ((x^.left^.typ^.form < f) OR (f > g)) THEN
  655.    (* don't create new node *)
  656.    IF x^.left^.typ = typ THEN (* and suppress existing node *) x := x^.left END
  657.   ELSE node := OPT.NewNode(Nmop); node^.subcl := conv; node^.left := x; x := node
  658.   END ;
  659.   x^.typ := typ
  660.  END Convert;
  661.  PROCEDURE Op*(op: SHORTINT; VAR x: OPT.Node; y: OPT.Node);
  662.   VAR f, g: INTEGER; t: OPT.Node; typ: OPT.Struct; do: BOOLEAN; val: LONGINT;
  663.   PROCEDURE NewOp;
  664.    VAR node: OPT.Node;
  665.   BEGIN
  666.    node := OPT.NewNode(Ndop); node^.subcl := op; node^.typ := typ;
  667.    node^.left := x; node^.right := y; x := node
  668.   END NewOp;
  669.   PROCEDURE strings(): BOOLEAN;
  670.    VAR ok, xCharArr, yCharArr: BOOLEAN;
  671.   BEGIN
  672.    xCharArr := ((x^.typ^.comp IN {Array, DynArr}) & (x^.typ^.BaseTyp^.form=Char)) OR (f=String);
  673.    yCharArr := (((y^.typ^.comp IN {Array, DynArr}) & (y^.typ^.BaseTyp^.form=Char)) OR (g=String));
  674.    IF xCharArr & (g = Char) & (y^.class = Nconst) THEN CharToString(y); g := String; yCharArr := TRUE END ;
  675.    IF yCharArr & (f = Char) & (x^.class = Nconst) THEN CharToString(x); f := String; xCharArr := TRUE END ;
  676.    ok := xCharArr & yCharArr;
  677.    IF ok THEN (* replace ""-string compare with 0X-char compare, if possible *)
  678.     IF (f=String) & (x^.conval^.intval2 = 1) THEN (* y is array of char *)
  679.      x^.typ := OPT.chartyp; x^.conval^.intval := 0;
  680.      Index(y, NewIntConst(0))
  681.     ELSIF (g=String) & (y^.conval^.intval2 = 1) THEN (* x is array of char *)
  682.      y^.typ := OPT.chartyp; y^.conval^.intval := 0;
  683.      Index(x, NewIntConst(0))
  684.     END
  685.    END ;
  686.    RETURN ok
  687.   END strings;
  688.  BEGIN
  689.   IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126)
  690.   ELSIF (x^.class = Nconst) & (y^.class = Nconst) THEN ConstOp(op, x, y); x^.obj := NIL
  691.   ELSE
  692.    IF x^.typ # y^.typ THEN
  693.     g := y^.typ^.form;
  694.     CASE x^.typ^.form OF
  695.        SInt:
  696.       IF g IN intSet + realSet THEN Convert(x, y^.typ)
  697.       ELSE  err(100)
  698.       END
  699.     | Int:
  700.       IF g = SInt THEN Convert(y, x^.typ)
  701.       ELSIF g IN intSet + realSet THEN Convert(x, y^.typ)
  702.       ELSE  err(100)
  703.       END
  704.     | LInt:
  705.       IF g IN intSet THEN Convert(y, x^.typ)
  706.       ELSIF g IN realSet THEN Convert(x, y^.typ)
  707.       ELSE  err(100)
  708.       END
  709.     | Real:
  710.       IF g IN intSet THEN Convert(y, x^.typ)
  711.       ELSIF g IN realSet THEN Convert(x, y^.typ)
  712.       ELSE  err(100)
  713.       END
  714.     | LReal:
  715.       IF g IN intSet + realSet THEN Convert(y, x^.typ)
  716.       ELSIF g IN realSet THEN Convert(y, x^.typ)
  717.       ELSE  err(100)
  718.       END
  719.     | NilTyp:
  720.       IF ~(g IN {Pointer, ProcTyp}) THEN err(100) END
  721.     | Pointer:
  722.       CheckPtr(x, y)
  723.     | ProcTyp:
  724.       IF g # NilTyp THEN err(100) END
  725.     | String:
  726.     | Comp:
  727.       IF x^.typ^.comp = Record THEN err(100) END
  728.     ELSE err(100)
  729.     END
  730.    END ; (* {x^.typ = y^.typ} *)
  731.    typ := x^.typ; f := typ^.form; g := y^.typ^.form;
  732.    CASE op OF
  733.      times:
  734.      do := TRUE;
  735.      IF f IN intSet THEN
  736.       IF x^.class = Nconst THEN val := x^.conval^.intval;
  737.        IF val = 1 THEN do := FALSE; x := y
  738.        ELSIF val = 0 THEN do := FALSE
  739.        ELSIF log(val) = 1 THEN
  740.         t := y; y := x; x := t;
  741.         op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL
  742.        END
  743.       ELSIF y^.class = Nconst THEN val := y^.conval^.intval;
  744.        IF val = 1 THEN do := FALSE
  745.        ELSIF val = 0 THEN do := FALSE; x := y
  746.        ELSIF log(val) = 1 THEN
  747.         op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL
  748.        END
  749.       END
  750.      ELSIF ~(f IN {Undef, Real..Set}) THEN err(105); typ := OPT.undftyp
  751.      END ;
  752.      IF do THEN NewOp END
  753.    | slash:
  754.      IF f IN intSet THEN
  755.       IF (y^.class = Nconst) & (y^.conval^.intval = 0) THEN err(205) END ;
  756.       Convert(x, OPT.realtyp); Convert(y, OPT.realtyp);
  757.       typ := OPT.realtyp
  758.      ELSIF f IN realSet THEN
  759.       IF (y^.class = Nconst) & (y^.conval^.realval = 0(*.0*)) THEN err(205) END
  760.      ELSIF (f # Set) & (f # Undef) THEN err(102); typ := OPT.undftyp
  761.      END ;
  762.      NewOp
  763.    | div:
  764.      do := TRUE;
  765.      IF f IN intSet THEN
  766.       IF y^.class = Nconst THEN val := y^.conval^.intval;
  767.        IF val = 0 THEN err(205)
  768.        ELSIF val = 1 THEN do := FALSE
  769.        ELSIF log(val) = 1 THEN
  770.         op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := -exp; y^.obj := NIL
  771.        END
  772.       END
  773.      ELSIF f # Undef THEN err(103); typ := OPT.undftyp
  774.      END ;
  775.      IF do THEN NewOp END
  776.    | mod:
  777.      IF f IN intSet THEN
  778.       IF y^.class = Nconst THEN
  779.        IF y^.conval^.intval = 0 THEN err(205)
  780.        ELSIF log(y^.conval^.intval) = 1 THEN
  781.         op := msk; y^.conval^.intval := ASH(-1, exp); y^.obj := NIL
  782.        END
  783.       END
  784.      ELSIF f # Undef THEN err(104); typ := OPT.undftyp
  785.      END ;
  786.      NewOp
  787.    | and:
  788.      IF f = Bool THEN
  789.       IF x^.class = Nconst THEN
  790.        IF IntToBool(x^.conval^.intval) THEN x := y END
  791.       ELSIF (y^.class = Nconst) & IntToBool(y^.conval^.intval) THEN (* optimize x & TRUE -> x *)
  792.     (* ELSIF (y^.class = Nconst) & ~IntToBool(y^.conval^.intval) THEN
  793.        don't optimize x & FALSE -> FALSE: side effects possible *)
  794.       ELSE NewOp
  795.       END
  796.      ELSIF f # Undef THEN err(94); x^.typ := OPT.undftyp
  797.      END
  798.    | plus:
  799.      IF ~(f IN {Undef, SInt..Set}) THEN err(105); typ := OPT.undftyp END ;
  800.      do := TRUE;
  801.      IF f IN intSet THEN
  802.       IF (x^.class = Nconst) & (x^.conval^.intval = 0) THEN do := FALSE; x := y END ;
  803.       IF (y^.class = Nconst) & (y^.conval^.intval = 0) THEN do := FALSE END
  804.      END ;
  805.      IF do THEN NewOp END
  806.    | minus:
  807.      IF ~(f IN {Undef, SInt..Set}) THEN err(106); typ := OPT.undftyp END ;
  808.      IF ~(f IN intSet) OR (y^.class # Nconst) OR (y^.conval^.intval # 0) THEN NewOp END
  809.    | or:
  810.      IF f = Bool THEN
  811.       IF x^.class = Nconst THEN
  812.        IF ~IntToBool(x^.conval^.intval) THEN x := y END
  813.       ELSIF (y^.class = Nconst) & ~IntToBool(y^.conval^.intval) THEN (* optimize x OR FALSE -> x *)
  814.     (* ELSIF (y^.class = Nconst) & IntToBool(y^.conval^.intval) THEN
  815.        don't optimize x OR TRUE -> TRUE: side effects possible *)
  816.       ELSE NewOp
  817.       END
  818.      ELSIF f # Undef THEN err(95); x^.typ := OPT.undftyp
  819.      END
  820.    | eql, neq:
  821.      IF (f IN {Undef..Set, NilTyp, Pointer, ProcTyp}) OR strings() THEN typ := OPT.booltyp
  822.      ELSE err(107); typ := OPT.undftyp
  823.      END ;
  824.      NewOp
  825.    | lss, leq, gtr, geq:
  826.      IF (f IN {Undef, Char..LReal}) OR strings() THEN typ := OPT.booltyp
  827.      ELSE err(108); typ := OPT.undftyp
  828.      END ;
  829.      NewOp
  830.    END
  831.   END
  832.  END Op;
  833.  PROCEDURE SetRange*(VAR x: OPT.Node; y: OPT.Node);
  834.   VAR k, l: LONGINT;
  835.  BEGIN
  836.   IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126)
  837.   ELSIF (x^.typ^.form IN intSet) & (y^.typ^.form IN intSet) THEN
  838.    IF x^.class = Nconst THEN
  839.     k := x^.conval^.intval;
  840.     IF (0 > k) OR (k > OPM.MaxSet) THEN err(202) END
  841.    END ;
  842.    IF y^.class = Nconst THEN
  843.     l := y^.conval^.intval;
  844.     IF (0 > l) OR (l > OPM.MaxSet) THEN err(202) END
  845.    END ;
  846.    IF (x^.class = Nconst) & (y^.class = Nconst) THEN
  847.     IF k <= l THEN
  848.      x^.conval^.setval := {k..l}
  849.     ELSE err(201); x^.conval^.setval := {l..k}
  850.     END ;
  851.     x^.obj := NIL
  852.    ELSE BindNodes(Nupto, OPT.settyp, x, y)
  853.    END
  854.   ELSE err(93)
  855.   END ;
  856.   x^.typ := OPT.settyp
  857.  END SetRange;
  858.  PROCEDURE SetElem*(VAR x: OPT.Node);
  859.   VAR k: LONGINT;
  860.  BEGIN
  861.   IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  862.   ELSIF ~(x^.typ^.form IN intSet) THEN err(93)
  863.   ELSIF x^.class = Nconst THEN
  864.    k := x^.conval^.intval;
  865.    IF (0 <= k) & (k <= OPM.MaxSet) THEN x^.conval^.setval := {k}
  866.    ELSE err(202)
  867.    END ;
  868.    x^.obj := NIL
  869.   ELSE Convert(x, OPT.settyp)
  870.   END ;
  871.   x^.typ := OPT.settyp
  872.  END SetElem;
  873.  PROCEDURE CheckAssign(x: OPT.Struct; ynode: OPT.Node); (* x := y *)
  874.   VAR f, g: INTEGER; y, p, q: OPT.Struct;
  875.  BEGIN
  876.   y := ynode^.typ; f := x^.form; g := y^.form;
  877.   IF (ynode^.class = Ntype) OR (ynode^.class = Nproc) & (f # ProcTyp) THEN err(126) END ;
  878.   CASE f OF
  879.     Undef:
  880.   | Byte:
  881.     IF ~(g IN {Byte, Char, SInt}) THEN err(113) END
  882.   | Bool, Char, SInt, Set:
  883.     IF g # f THEN err(113) END
  884.   | Int:
  885.     IF ~(g IN {SInt, Int}) THEN err(113) END
  886.   | LInt:
  887.     IF ~(g IN intSet) THEN err(113) END
  888.   | Real:
  889.     IF ~(g IN {SInt..Real}) THEN err(113) END
  890.   | LReal:
  891.     IF ~(g IN {SInt..LReal}) THEN err(113) END
  892.   | Pointer:
  893.     IF (x = y) OR (g = NilTyp) OR (x = OPT.sysptrtyp) & (g = Pointer) THEN (* ok *)
  894.     ELSIF g = Pointer THEN
  895.      p := x^.BaseTyp; q := y^.BaseTyp;
  896.      IF (p^.comp = Record) & (q^.comp = Record) THEN
  897.       WHILE (q # p) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ;
  898.       IF q = NIL THEN err(113) END
  899.      ELSE err(113)
  900.      END
  901.     ELSE err(113)
  902.     END
  903.   | ProcTyp:
  904.     IF ynode^.class = Nproc THEN CheckProc(x, ynode^.obj)
  905.     ELSIF (x = y) OR (g = NilTyp) THEN (* ok *)
  906.     ELSE err(113)
  907.     END
  908.   | NoTyp, NilTyp:
  909.     err(113)
  910.   | Comp:
  911.     IF x^.comp = Array THEN
  912.      IF (ynode^.class = Nconst) & (g = Char) THEN CharToString(ynode); y := ynode^.typ; g := String END ;
  913.      IF x = y THEN (* ok *)
  914.      ELSIF (g = String) & (x^.BaseTyp = OPT.chartyp) THEN (*check length of string*)
  915.       IF ynode^.conval^.intval2 > x^.n THEN err(114) END ;
  916.      ELSE err(113)
  917.      END
  918.     ELSIF x^.comp = Record THEN
  919.      IF x = y THEN (* ok *)
  920.      ELSIF y^.comp = Record THEN
  921.       q := y^.BaseTyp;
  922.       WHILE (q # NIL) & (q # x) & (q # OPT.undftyp) DO q := q^.BaseTyp END ;
  923.       IF q = NIL THEN err(113) END
  924.      ELSE err(113)
  925.      END
  926.     ELSE (*DynArr*) err(113)
  927.     END
  928.   END ;
  929.   IF (ynode^.class = Nconst) & (g < f) & (g IN {SInt..Real}) & (f IN {Int..LReal}) THEN
  930.    Convert(ynode, x)
  931.   END
  932.  END CheckAssign;
  933.  PROCEDURE CheckLeaf(x: OPT.Node; dynArrToo: BOOLEAN);
  934.  BEGIN
  935.   IF (x^.class = Nmop) & (x^.subcl = val) THEN x := x^.left END ;
  936.   IF x^.class = Nguard THEN x := x^.left END ; (* skip last (and unique) guard *)
  937.   IF (x^.class = Nvar) & (dynArrToo OR (x^.typ^.comp # DynArr)) THEN x^.obj^.leaf := FALSE END
  938.  END CheckLeaf;
  939.  PROCEDURE StPar0*(VAR par0: OPT.Node; fctno: INTEGER); (* par0: first param of standard proc *)
  940.   VAR f: INTEGER; typ: OPT.Struct; x: OPT.Node;
  941.  BEGIN x := par0; f := x^.typ^.form;
  942.   CASE fctno OF
  943.     haltfn: (*HALT*)
  944.     IF (f IN intSet) & (x^.class = Nconst) THEN
  945.      IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN
  946.       BindNodes(Ntrap, OPT.notyp, x, x)
  947.      ELSE err(218)
  948.      END
  949.     ELSE err(69)
  950.     END ;
  951.     x^.typ := OPT.notyp
  952.   | newfn: (*NEW*)
  953.     typ := OPT.notyp;
  954.     IF NotVar(x) THEN err(112)
  955.     ELSIF f = Pointer THEN
  956.      IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ;
  957.      IF x^.readonly THEN err(76) END ;
  958.      f := x^.typ^.BaseTyp^.comp;
  959.      IF f IN {Record, DynArr, Array} THEN
  960.       IF f = DynArr THEN typ := x^.typ^.BaseTyp END ;
  961.       BindNodes(Nassign, OPT.notyp, x, NIL); x^.subcl := newfn
  962.      ELSE err(111)
  963.      END
  964.     ELSE err(111)
  965.     END ;
  966.     x^.typ := typ
  967.   | absfn: (*ABS*)
  968.     MOp(abs, x)
  969.   | capfn: (*CAP*)
  970.     MOp(cap, x)
  971.   | ordfn: (*ORD*)
  972.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  973.     ELSIF f = Char THEN Convert(x, OPT.inttyp)
  974.     ELSE err(111)
  975.     END ;
  976.     x^.typ := OPT.inttyp
  977.   | entierfn: (*ENTIER*)
  978.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  979.     ELSIF f IN realSet THEN Convert(x, OPT.linttyp)
  980.     ELSE err(111)
  981.     END ;
  982.     x^.typ := OPT.linttyp
  983.   | oddfn: (*ODD*)
  984.     MOp(odd, x)
  985.   | minfn: (*MIN*)
  986.     IF x^.class = Ntype THEN
  987.      CASE f OF
  988.        Bool:  x := NewBoolConst(FALSE)
  989.      | Char:  x := NewIntConst(0); x^.typ := OPT.chartyp
  990.      | SInt:  x := NewIntConst(OPM.MinSInt)
  991.      | Int:   x := NewIntConst(OPM.MinInt)
  992.      | LInt:  x := NewIntConst(OPM.MinLInt)
  993.      | Set:   x := NewIntConst(0); x^.typ := OPT.inttyp
  994.      | Real:  x := NewRealConst(OPM.MinReal, OPT.realtyp)
  995.      | LReal: x := NewRealConst(OPM.MinLReal, OPT.lrltyp)
  996.      ELSE err(111)
  997.      END
  998.     ELSE err(110)
  999.     END
  1000.   | maxfn: (*MAX*)
  1001.     IF x^.class = Ntype THEN
  1002.      CASE f OF
  1003.        Bool:  x := NewBoolConst(TRUE)
  1004.      | Char:  x := NewIntConst(0FFH); x^.typ := OPT.chartyp
  1005.      | SInt:  x := NewIntConst(OPM.MaxSInt)
  1006.      | Int:   x := NewIntConst(OPM.MaxInt)
  1007.      | LInt:  x := NewIntConst(OPM.MaxLInt)
  1008.      | Set:   x := NewIntConst(OPM.MaxSet); x^.typ := OPT.inttyp
  1009.      | Real:  x := NewRealConst(OPM.MaxReal, OPT.realtyp)
  1010.      | LReal: x := NewRealConst(OPM.MaxLReal, OPT.lrltyp)
  1011.      ELSE err(111)
  1012.      END
  1013.     ELSE err(110)
  1014.     END
  1015.   | chrfn: (*CHR*)
  1016.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1017.     ELSIF f IN {Undef, SInt..LInt} THEN Convert(x, OPT.chartyp)
  1018.     ELSE err(111); x^.typ := OPT.chartyp
  1019.     END
  1020.   | shortfn: (*SHORT*)
  1021.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1022.     ELSIF f = Int THEN Convert(x, OPT.sinttyp)
  1023.     ELSIF f = LInt THEN Convert(x, OPT.inttyp)
  1024.     ELSIF f = LReal THEN Convert(x, OPT.realtyp)
  1025.     ELSE err(111)
  1026.     END
  1027.   | longfn: (*LONG*)
  1028.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1029.     ELSIF f = SInt THEN Convert(x, OPT.inttyp)
  1030.     ELSIF f = Int THEN Convert(x, OPT.linttyp)
  1031.     ELSIF f = Real THEN Convert(x, OPT.lrltyp)
  1032.     ELSIF f = Char THEN Convert(x, OPT.linttyp)
  1033.     ELSE err(111)
  1034.     END
  1035.   | incfn, decfn: (*INC, DEC*)
  1036.     IF NotVar(x) THEN err(112)
  1037.     ELSIF ~(f IN intSet) THEN err(111)
  1038.     ELSIF x^.readonly THEN err(76)
  1039.     END
  1040.   | inclfn, exclfn: (*INCL, EXCL*)
  1041.     IF NotVar(x) THEN err(112)
  1042.     ELSIF x^.typ # OPT.settyp THEN err(111); x^.typ := OPT.settyp
  1043.     ELSIF x^.readonly THEN err(76)
  1044.     END
  1045.   | lenfn: (*LEN*)
  1046.     IF ~(x^.typ^.comp IN {DynArr, Array}) THEN err(131) END
  1047.   | copyfn: (*COPY*)
  1048.     IF (x^.class = Nconst) & (f = Char) THEN CharToString(x); f := String END ;
  1049.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1050.     ELSIF (~(x^.typ^.comp IN {DynArr, Array}) OR (x^.typ^.BaseTyp^.form # Char))
  1051.       & (f # String) THEN err(111)
  1052.     END
  1053.   | ashfn: (*ASH*)
  1054.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1055.     ELSIF f IN intSet THEN
  1056.      IF f # LInt THEN Convert(x, OPT.linttyp) END
  1057.     ELSE err(111); x^.typ := OPT.linttyp
  1058.     END
  1059.   | adrfn: (*SYSTEM.ADR*)
  1060.     CheckLeaf(x, FALSE); MOp(adr, x)
  1061.   | sizefn: (*SIZE*)
  1062.     IF x^.class # Ntype THEN err(110); x := NewIntConst(1)
  1063.     ELSIF (f IN {Byte..Set, Pointer, ProcTyp}) OR (x^.typ^.comp IN {Array, Record}) THEN
  1064.      typSize(x^.typ, FALSE); x := NewIntConst(x^.typ^.size)
  1065.     ELSE err(111); x := NewIntConst(1)
  1066.     END
  1067.   | ccfn: (*SYSTEM.CC*)
  1068.     MOp(cc, x)
  1069.   | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*)
  1070.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1071.     ELSIF ~(f IN intSet + {Byte, Char, Set}) THEN err(111)
  1072.     END
  1073.   | getfn, putfn, bitfn, movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*)
  1074.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1075.     ELSIF (x^.class = Nconst) & (f IN {SInt, Int}) THEN Convert(x, OPT.linttyp)
  1076.     ELSIF ~(f IN {LInt, Pointer}) THEN err(111); x^.typ := OPT.linttyp
  1077.     END
  1078.   | getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*)
  1079.     IF (f IN intSet) & (x^.class = Nconst) THEN
  1080.      IF (x^.conval^.intval < OPM.MinRegNr) OR (x^.conval^.intval > OPM.MaxRegNr) THEN err(220) END
  1081.     ELSE err(69)
  1082.     END
  1083.   | valfn: (*SYSTEM.VAL*)
  1084.     IF x^.class # Ntype THEN err(110)
  1085.     ELSIF (f IN {Undef, String, NoTyp}) OR (x^.typ^.comp = DynArr) THEN err(111)
  1086.     END
  1087.   | sysnewfn: (*SYSTEM.NEW*)
  1088.     IF NotVar(x) THEN err(112)
  1089.     ELSIF f = Pointer THEN
  1090.      IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END
  1091.     ELSE err(111)
  1092.     END
  1093.   | assertfn: (*ASSERT*)
  1094.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); x := NewBoolConst(FALSE)
  1095.     ELSIF f # Bool THEN err(120); x := NewBoolConst(FALSE)
  1096.     ELSE MOp(not, x)
  1097.     END
  1098.   END ;
  1099.   par0 := x
  1100.  END StPar0;
  1101.  PROCEDURE StPar1*(VAR par0: OPT.Node; x: OPT.Node; fctno: SHORTINT); (* x: second parameter of standard proc *)
  1102.   VAR f, L: INTEGER; typ: OPT.Struct; p, t: OPT.Node;
  1103.   PROCEDURE NewOp(class: SHORTINT);
  1104.    VAR node: OPT.Node;
  1105.   BEGIN
  1106.    node := OPT.NewNode(class);
  1107.    node^.left := p; node^.right := x; p := node
  1108.   END NewOp;
  1109.  BEGIN p := par0; f := x^.typ^.form;
  1110.   CASE fctno OF
  1111.     incfn, decfn: (*INC DEC*)
  1112.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); p^.typ := OPT.notyp
  1113.     ELSE
  1114.      IF x^.typ # p^.typ THEN
  1115.       IF (x^.class = Nconst) & (f IN intSet) THEN Convert(x, p^.typ)
  1116.       ELSE err(111)
  1117.       END
  1118.      END ;
  1119.      NewOp(Nassign); p^.subcl := fctno;
  1120.      p^.typ := OPT.notyp
  1121.     END
  1122.   | inclfn, exclfn: (*INCL, EXCL*)
  1123.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1124.     ELSIF f IN intSet THEN
  1125.      IF (x^.class = Nconst) & ((0 > x^.conval^.intval) OR (x^.conval^.intval > OPM.MaxSet)) THEN err(202)
  1126.      END ;
  1127.      NewOp(Nassign); p^.subcl := fctno
  1128.     ELSE err(111)
  1129.     END ;
  1130.     p^.typ := OPT.notyp
  1131.   | lenfn: (*LEN*)
  1132.     IF ~(f IN intSet) OR (x^.class # Nconst) THEN err(69)
  1133.     ELSIF f = SInt THEN
  1134.      L := SHORT(x^.conval^.intval); typ := p^.typ;
  1135.      WHILE (L > 0) & (typ^.comp IN {DynArr, Array}) DO typ := typ^.BaseTyp; DEC(L) END ;
  1136.      IF (L # 0) OR ~(typ^.comp IN {DynArr, Array}) THEN err(132)
  1137.      ELSE x^.obj := NIL;
  1138.       IF typ^.comp = DynArr THEN
  1139.        WHILE p^.class = Nindex DO p := p^.left; INC(x^.conval^.intval) END ; (* possible side effect ignored *)
  1140.        NewOp(Ndop); p^.subcl := len; p^.typ := OPT.linttyp
  1141.       ELSE p := x; p^.conval^.intval := typ^.n; SetIntType(p)
  1142.       END
  1143.      END
  1144.     ELSE err(132)
  1145.     END
  1146.   | copyfn: (*COPY*)
  1147.     IF NotVar(x) THEN err(112)
  1148.     ELSIF (x^.typ^.comp IN {Array, DynArr}) & (x^.typ^.BaseTyp^.form = Char) THEN
  1149.      IF x^.readonly THEN err(76) END ;
  1150.      t := x; x := p; p := t; NewOp(Nassign); p^.subcl := copyfn
  1151.     ELSE err(111)
  1152.     END ;
  1153.     p^.typ := OPT.notyp
  1154.   | ashfn: (*ASH*)
  1155.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1156.     ELSIF f IN intSet THEN
  1157.      IF (p^.class = Nconst) & (x^.class = Nconst) THEN
  1158.       IF (-maxExp > x^.conval^.intval) OR (x^.conval^.intval > maxExp) THEN err(208); p^.conval^.intval := 1
  1159.       ELSIF x^.conval^.intval >= 0 THEN
  1160.        IF ABS(p^.conval^.intval) <= MAX(LONGINT) DIV ASH(1, x^.conval^.intval) THEN
  1161.         p^.conval^.intval := p^.conval^.intval * ASH(1, x^.conval^.intval)
  1162.        ELSE err(208); p^.conval^.intval := 1
  1163.        END
  1164.       ELSE p^.conval^.intval := ASH(p^.conval^.intval, x^.conval^.intval)
  1165.       END ;
  1166.       p^.obj := NIL
  1167.      ELSE NewOp(Ndop); p^.subcl := ash; p^.typ := OPT.linttyp
  1168.      END
  1169.     ELSE err(111)
  1170.     END
  1171.   | newfn: (*NEW(p, x...)*)
  1172.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1173.     ELSIF p^.typ^.comp = DynArr THEN
  1174.      IF f IN intSet THEN
  1175.       IF (x^.class = Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END
  1176.      ELSE err(111)
  1177.      END ;
  1178.      p^.right := x; p^.typ := p^.typ^.BaseTyp
  1179.     ELSE err(64)
  1180.     END
  1181.   | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*)
  1182.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1183.     ELSIF ~(f IN intSet) THEN err(111)
  1184.     ELSE NewOp(Ndop); p^.typ := p^.left^.typ;
  1185.      IF fctno = lshfn THEN p^.subcl := lsh ELSE p^.subcl := rot END
  1186.     END
  1187.   | getfn, putfn, getrfn, putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*)
  1188.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1189.     ELSIF f IN {Undef..Set, Pointer, ProcTyp} THEN
  1190.      IF (fctno = getfn) OR (fctno = getrfn) THEN
  1191.       IF NotVar(x) THEN err(112) END ;
  1192.       t := x; x := p; p := t
  1193.      END ;
  1194.      NewOp(Nassign); p^.subcl := fctno
  1195.     ELSE err(111)
  1196.     END ;
  1197.     p^.typ := OPT.notyp
  1198.   | bitfn: (*SYSTEM.BIT*)
  1199.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1200.     ELSIF f IN intSet THEN
  1201.      NewOp(Ndop); p^.subcl := bit
  1202.     ELSE err(111)
  1203.     END ;
  1204.     p^.typ := OPT.booltyp
  1205.   | valfn: (*SYSTEM.VAL*) (* type is changed without considering the byte ordering on the target machine *)
  1206.     IF (x^.class = Ntype) OR (x^.class = Nproc) OR
  1207.      (f IN {Undef, String, NoTyp}) OR (x^.typ^.comp = DynArr) THEN err(126)
  1208.     END ;
  1209.     IF (x^.class >= Nconst) OR ((f IN realSet) # (p^.typ^.form IN realSet)) THEN
  1210.      t := OPT.NewNode(Nmop); t^.subcl := val; t^.left := x; x := t
  1211.     ELSE x^.readonly := FALSE
  1212.     END ;
  1213.     x^.typ := p^.typ; p := x
  1214.   | sysnewfn: (*SYSTEM.NEW*)
  1215.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1216.     ELSIF f IN intSet THEN
  1217.      NewOp(Nassign); p^.subcl := sysnewfn
  1218.     ELSE err(111)
  1219.     END ;
  1220.     p^.typ := OPT.notyp
  1221.   | movefn: (*SYSTEM.MOVE*)
  1222.     IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1223.     ELSIF (x^.class = Nconst) & (f IN {SInt, Int}) THEN Convert(x, OPT.linttyp)
  1224.     ELSIF ~(f IN {LInt, Pointer}) THEN err(111); x^.typ := OPT.linttyp
  1225.     END ;
  1226.     p^.link := x
  1227.   | assertfn: (*ASSERT*)
  1228.     IF (f IN intSet) & (x^.class = Nconst) THEN
  1229.      IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN
  1230.       BindNodes(Ntrap, OPT.notyp, x, x);
  1231.       x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos;
  1232.       Construct(Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos;
  1233.       Construct(Nifelse, p, NIL); OptIf(p);
  1234.       IF p = NIL THEN (* ASSERT(TRUE) *)
  1235.       ELSIF p^.class = Ntrap THEN err(99)
  1236.       ELSE p^.subcl := assertfn
  1237.       END
  1238.      ELSE err(218)
  1239.      END
  1240.     ELSE err(69)
  1241.     END
  1242.   ELSE err(64)
  1243.   END ;
  1244.   par0 := p
  1245.  END StPar1;
  1246.  PROCEDURE StParN*(VAR par0: OPT.Node; x: OPT.Node; fctno, n: INTEGER); (* x: n+1-th param of standard proc *)
  1247.   VAR node: OPT.Node; f: INTEGER; p: OPT.Node;
  1248.  BEGIN p := par0; f := x^.typ^.form;
  1249.   IF fctno = newfn THEN (*NEW(p, ..., x...*)
  1250.    IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1251.    ELSIF p^.typ^.comp # DynArr THEN err(64)
  1252.    ELSIF f IN intSet THEN
  1253.     IF (x^.class = Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END ;
  1254.     node := p^.right; WHILE node^.link # NIL DO node := node^.link END;
  1255.     node^.link := x; p^.typ := p^.typ^.BaseTyp
  1256.    ELSE err(111)
  1257.    END
  1258.   ELSIF (fctno = movefn) & (n = 2) THEN (*SYSTEM.MOVE*)
  1259.    IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1260.    ELSIF f IN intSet THEN
  1261.     node := OPT.NewNode(Nassign); node^.subcl := movefn; node^.right := p;
  1262.     node^.left := p^.link; p^.link := x; p := node
  1263.    ELSE err(111)
  1264.    END ;
  1265.    p^.typ := OPT.notyp
  1266.   ELSE err(64)
  1267.   END ;
  1268.   par0 := p
  1269.  END StParN;
  1270.  PROCEDURE StFct*(VAR par0: OPT.Node; fctno: SHORTINT; parno: INTEGER);
  1271.   VAR dim: INTEGER; x, p: OPT.Node;
  1272.  BEGIN p := par0;
  1273.   IF fctno <= ashfn THEN
  1274.    IF (fctno = newfn) & (p^.typ # OPT.notyp) THEN
  1275.     IF p^.typ^.comp = DynArr THEN err(65) END ;
  1276.     p^.typ := OPT.notyp
  1277.    ELSIF fctno <= sizefn THEN (* 1 param *)
  1278.     IF parno < 1 THEN err(65) END
  1279.    ELSE (* more than 1 param *)
  1280.     IF ((fctno = incfn) OR (fctno = decfn)) & (parno = 1) THEN (*INC, DEC*)
  1281.      BindNodes(Nassign, OPT.notyp, p, NewIntConst(1)); p^.subcl := fctno
  1282.     ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*)
  1283.      IF p^.typ^.comp = DynArr THEN dim := 0;
  1284.       WHILE p^.class = Nindex DO p := p^.left; INC(dim) END ; (* possible side effect ignored *)
  1285.       BindNodes(Ndop, OPT.linttyp, p, NewIntConst(dim)); p^.subcl := len
  1286.      ELSE
  1287.       p := NewIntConst(p^.typ^.n)
  1288.      END
  1289.     ELSIF parno < 2 THEN err(65)
  1290.     END
  1291.    END
  1292.   ELSIF fctno = assertfn THEN
  1293.    IF parno = 1 THEN x := NIL;
  1294.     BindNodes(Ntrap, OPT.notyp, x, NewIntConst(AssertTrap));
  1295.     x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos;
  1296.     Construct(Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos;
  1297.     Construct(Nifelse, p, NIL); OptIf(p);
  1298.     IF p = NIL THEN (* ASSERT(TRUE) *)
  1299.     ELSIF p^.class = Ntrap THEN err(99)
  1300.     ELSE p^.subcl := assertfn
  1301.     END
  1302.    ELSIF parno < 1 THEN err(65)
  1303.    END
  1304.   ELSE (*SYSTEM*)
  1305.    IF (parno < 1) OR
  1306.     (fctno > ccfn) & (parno < 2) OR
  1307.     (fctno = movefn) & (parno < 3) THEN err(65)
  1308.    END
  1309.   END ;
  1310.   par0 := p
  1311.  END StFct;
  1312.  PROCEDURE DynArrParCheck(ftyp, atyp: OPT.Struct; fvarpar: BOOLEAN);
  1313.   VAR f: INTEGER;
  1314.  BEGIN (* ftyp^.comp = DynArr *)
  1315.   f := atyp^.comp; ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp;
  1316.   IF fvarpar & (ftyp = OPT.bytetyp) THEN (* ok, but ... *)
  1317.    IF ~(f IN {Array, DynArr}) OR ~(atyp^.form IN {Byte..SInt}) THEN err(-301) END (* ... warning 301 *)
  1318.   ELSIF f IN {Array, DynArr} THEN
  1319.    IF ftyp^.comp = DynArr THEN DynArrParCheck(ftyp, atyp, fvarpar)
  1320.    ELSIF ftyp # atyp THEN
  1321.     IF ~fvarpar & (ftyp.form = Pointer) & (atyp.form = Pointer) THEN
  1322.      ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp;
  1323.      IF (ftyp^.comp = Record) & (atyp^.comp = Record) THEN
  1324.       WHILE (ftyp # atyp) & (atyp # NIL) & (atyp # OPT.undftyp) DO atyp := atyp^.BaseTyp END ;
  1325.       IF atyp = NIL THEN err(113) END
  1326.      ELSE err(66)
  1327.      END
  1328.     ELSE err(66)
  1329.     END
  1330.    END ;
  1331.   ELSE err(67)
  1332.   END
  1333.  END DynArrParCheck;
  1334.  PROCEDURE CheckReceiver(VAR x: OPT.Node; fp: OPT.Object);
  1335.  BEGIN
  1336.   IF fp^.typ^.form = Pointer THEN
  1337.    IF x^.class = Nderef THEN x := x^.left (*undo DeRef*) ELSE (*x^.typ^.comp = Record*) err(71) END
  1338.   END
  1339.  END CheckReceiver;
  1340.  PROCEDURE PrepCall*(VAR x: OPT.Node; VAR fpar: OPT.Object);
  1341.  BEGIN
  1342.   IF (x^.obj # NIL) & (x^.obj^.mode IN {LProc, XProc, TProc, CProc}) THEN
  1343.    fpar := x^.obj^.link;
  1344.    IF x^.obj^.mode = TProc THEN CheckReceiver(x^.left, fpar); fpar := fpar^.link END
  1345.   ELSIF (x^.class # Ntype) & (x^.typ # NIL) & (x^.typ^.form = ProcTyp) THEN
  1346.    fpar := x^.typ^.link
  1347.   ELSE err(121); fpar := NIL; x^.typ := OPT.undftyp
  1348.   END
  1349.  END PrepCall;
  1350.  PROCEDURE Param*(ap: OPT.Node; fp: OPT.Object);
  1351.   VAR q: OPT.Struct;
  1352.  BEGIN
  1353.   IF fp.typ.form # Undef THEN
  1354.    IF fp^.mode = VarPar THEN
  1355.     IF NotVar(ap) THEN err(122)
  1356.     ELSE CheckLeaf(ap, FALSE)
  1357.     END ;
  1358.     IF ap^.readonly THEN err(76) END ;
  1359.     IF fp^.typ^.comp = DynArr THEN DynArrParCheck(fp^.typ, ap^.typ, TRUE)
  1360.     ELSIF (fp^.typ^.comp = Record) & (ap^.typ^.comp = Record) THEN
  1361.      q := ap^.typ;
  1362.      WHILE (q # fp^.typ) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ;
  1363.      IF q = NIL THEN err(111) END
  1364.     ELSIF (fp^.typ = OPT.sysptrtyp) & (ap^.typ^.form = Pointer) THEN (* ok *)
  1365.     ELSIF (ap^.typ # fp^.typ) & ~((fp^.typ^.form = Byte) & (ap^.typ^.form IN {Char, SInt})) THEN err(123)
  1366.     END
  1367.    ELSIF fp^.typ^.comp = DynArr THEN
  1368.     IF (ap^.class = Nconst) & (ap^.typ^.form = Char) THEN CharToString(ap) END ;
  1369.     IF (ap^.typ^.form = String) & (fp^.typ^.BaseTyp^.form = Char) THEN (* ok *)
  1370.     ELSIF ap^.class >= Nconst THEN err(59)
  1371.     ELSE DynArrParCheck(fp^.typ, ap^.typ, FALSE)
  1372.     END
  1373.    ELSE CheckAssign(fp^.typ, ap)
  1374.    END
  1375.   END
  1376.  END Param;
  1377.  PROCEDURE StaticLink*(dlev: SHORTINT);
  1378.   VAR scope: OPT.Object;
  1379.  BEGIN
  1380.   scope := OPT.topScope;
  1381.   WHILE dlev > 0 DO DEC(dlev);
  1382.    INCL(scope^.link^.conval^.setval, slNeeded);
  1383.    scope := scope^.left
  1384.   END
  1385.  END StaticLink;
  1386.  PROCEDURE Call*(VAR x: OPT.Node; apar: OPT.Node; fp: OPT.Object);
  1387.   VAR typ: OPT.Struct; p: OPT.Node; lev: SHORTINT;
  1388.  BEGIN
  1389.   IF x^.class = Nproc THEN typ := x^.typ;
  1390.    lev := x^.obj^.mnolev;
  1391.    IF lev > 0 THEN StaticLink(OPT.topScope^.mnolev-lev) END ;
  1392.    IF x^.obj^.mode = IProc THEN err(121) END
  1393.   ELSIF (x^.class = Nfield) & (x^.obj^.mode = TProc) THEN typ := x^.typ;
  1394.    x^.class := Nproc; p := x^.left; x^.left := NIL; p^.link := apar; apar := p; fp := x^.obj^.link
  1395.   ELSE typ := x^.typ^.BaseTyp
  1396.   END ;
  1397.   BindNodes(Ncall, typ, x, apar); x^.obj := fp
  1398.  END Call;
  1399.  PROCEDURE Enter*(VAR procdec: OPT.Node; stat: OPT.Node; proc: OPT.Object);
  1400.   VAR x: OPT.Node;
  1401.  BEGIN
  1402.   x := OPT.NewNode(Nenter); x^.typ := OPT.notyp; x^.obj := proc;
  1403.   x^.left := procdec; x^.right := stat; procdec := x
  1404.  END Enter;
  1405.  PROCEDURE Return*(VAR x: OPT.Node; proc: OPT.Object);
  1406.   VAR node: OPT.Node;
  1407.  BEGIN
  1408.   IF proc = NIL THEN (* return from module *)
  1409.    IF x # NIL THEN err(124) END
  1410.   ELSE
  1411.    IF x # NIL THEN CheckAssign(proc^.typ, x)
  1412.    ELSIF proc^.typ # OPT.notyp THEN err(124)
  1413.    END
  1414.   END ;
  1415.   node := OPT.NewNode(Nreturn); node^.typ := OPT.notyp; node^.obj := proc; node^.left := x; x := node
  1416.  END Return;
  1417.  PROCEDURE Assign*(VAR x: OPT.Node; y: OPT.Node);
  1418.   VAR z: OPT.Node;
  1419.  BEGIN
  1420.   IF x^.class >= Nconst THEN err(56) END ;
  1421.   CheckAssign(x^.typ, y);
  1422.   IF x^.readonly THEN err(76) END ;
  1423.   IF x^.typ^.comp = Record THEN
  1424.    IF x^.class = Nguard THEN z := x^.left ELSE z := x END ;
  1425.    IF (z^.class = Nderef) & (z^.left^.class = Nguard) THEN
  1426.     z^.left := z^.left^.left (* skip guard before dereferencing *)
  1427.    END ;
  1428.    IF (x^.typ^.strobj # NIL) & ((z^.class = Nderef) OR (z^.class = Nvarpar)) THEN
  1429.     BindNodes(Neguard, x^.typ, z, NIL); x := z
  1430.    END
  1431.   ELSIF (x^.typ^.comp = Array) & (x^.typ^.BaseTyp = OPT.chartyp) &
  1432.     (y^.typ^.form = String) & (y^.conval^.intval2 = 1) THEN (* replace array := "" with array[0] := 0X *)
  1433.    y^.typ := OPT.chartyp; y^.conval^.intval := 0;
  1434.    Index(x, NewIntConst(0))
  1435.   END ;
  1436.   BindNodes(Nassign, OPT.notyp, x, y); x^.subcl := assign
  1437.  END Assign;
  1438.  PROCEDURE Inittd*(VAR inittd, last: OPT.Node; typ: OPT.Struct);
  1439.   VAR node: OPT.Node;
  1440.  BEGIN
  1441.   node := OPT.NewNode(Ninittd); node^.typ := typ;
  1442.   node^.conval := OPT.NewConst(); node^.conval^.intval := typ^.txtpos;
  1443.   IF inittd = NIL THEN inittd := node ELSE last^.link := node END ;
  1444.   last := node
  1445.  END Inittd;
  1446. BEGIN
  1447.  maxExp := log(MAX(LONGINT) DIV 2 + 1); maxExp := exp
  1448. END OPB.
  1449.